home *** CD-ROM | disk | FTP | other *** search
/ SPACE 2 / SPACE - Library 2 - Volume 1.iso / apps / 29 / applic / database.bas < prev    next >
BASIC Source File  |  1985-11-19  |  8KB  |  156 lines
  1. 1     fullw 2:clearw 2
  2. 5     dim l(30),q$(30):rem lenght og ques + data
  3. 7     C$="...............................: "
  4. 8     B$="    "
  5. 10    REM  ----- Ageneral data base program for the micropolis users group ---
  6. 11    REM --- written by ELWOOD Clarke for all to use - uncopyrightable---
  7. 12    REM   SET UP THE SIZE OF THE VARIABLE MATRIX
  8. 15    clearw 2
  9. 20    INPUT "The file name of the stored data ";F$
  10. 100   REM --- This is the menu section from line 100 - 199
  11. 105   clearw 2
  12. 110   PRINT "Init......Initalizes this file"
  13. 120   PRINT "Entr......Enters data"
  14. 130   PRINT "Look......Looks at data"
  15. 140   PRINT "Chng......Changes data"
  16. 150   PRINT "Srch......Searches for data"
  17. 160   PRINT "Del.......Deletes record"
  18. 165   PRINT "Quit......Leaves the program"
  19. 170   INPUT "Which function would you like ";O$
  20. 180   O$=LEFT$(O$,1):REM Take the first character of the answer
  21. 190   A=(O$="I")+(O$="E")*2+(O$="L")*3+(O$="C")*4+(O$="S")*5+(O$="D")*6+(O$="Q")*7:REM   Depending on 1 through 6
  22. 192   A=A+(O$="i")+(O$="e")*2+(O$="l")*3+(O$="c")*4+(O$="s")*5+(O$="d")*6+(O$="q")*7:REM  accept also lower case letters
  23. 193   A=ABS(A):A=A+1
  24. 195   ON A GOTO 100,200,300,400,500,600,700,800
  25. 200   REM ---- This is the file initialization program ---
  26. 205   GOSUB 1000: REM  REM   Open the file used for data storage
  27. 210   INPUT  " How many input questions are there?";L(0)
  28. 215   FOR X=1 TO L(O):REM   This loop lets one enter the questions
  29. 220   PRINT  "Enter the desired question for ";X;:INPUT  " ";Q$(X)
  30. 225   NEXT X
  31. 230   FOR X=1 TO L(0):REM Print out question list for error checking
  32. 235   PRINT X;"   ";Q$(X)
  33. 240   NEXT X
  34. 245   INPUT "The desired item to be corrected & `0' if none";X
  35. 250   IF X=0 THEN 280:REM   If all are correct save them
  36. 255   IF (X<1) OR (X>L(0)) THEN 245:REM  Out of range quewtions
  37. 260   INPUT "What should the new item be ";Q$(X)
  38. 265   GOTO 230: REM   End the edit of the questions
  39. 280   N=0:GOSUB 2000: REM   Pack the data and then return
  40. 285   Q1=1:GOSUB 1200:REM   Save record 1 which contains questions
  41. 290   GOSUB 1100: REM    Close the file
  42. 299   GOTO 100: REM    Return to the menu
  43. 300   REM    This is the data entry program----
  44. 305   GOSUB 1000: REM    Open the file used for data storage
  45. 310   Q1=1:GOSUB 1230:GOSUB 2100: REM----Get the file information and unpack it
  46. 315   FOR X=1 TO L(0): REM ---Input data loop
  47. 320   PRINT Q$(X);RIGHT$(C$,25-LEN(Q$(X)));:INPUT D$(X)
  48. 325   NEXT X
  49. 330   FOR X=1 TO L(0):PRINT X;"  ";Q$(X);RIGHT$(C$,25-LEN(Q$(X)));D$(X):NEXT X
  50. 335   INPUT  "Item number to be changed `0' if none ";X
  51. 340   IF X=0 THEN 370: REM ---If none then save the results
  52. 345   IF (X<1) OR (X>L(0)) THEN 335: REM---Out of range data value
  53. 350   PRINT Q$(X);"Should be ";:INPUT  D$(X): REM ---Correct it
  54. 355   GOTO 330: REM ---End of correct loop
  55. 370   N=N+1:GOSUB 2001:GOSUB 1200: REM ---Resave file header
  56. 375   GOSUB 2200:Q1=2*N+1:GOSUB 1200:REM ---Pack and save data on file in record n+1
  57. 380   GOSUB 1100: REM ---Close the file
  58. 399   GOTO 100: REM ---Return to the menu
  59. 400   REM ---This is the data inspection program---
  60. 401   GOSUB 1000: REM ---Open the file used for data storage---
  61. 405   Q1=1:GOSUB 1230:GOSUB 2100: REM ---Get file information and unpack it---
  62. 410   PRINT  "Which record would you like to see?"
  63. 411   PRINT "0=none, 1=min, ";N;"=max ";:INPUT X
  64. 415   IF (X=0) THEN GOTO 495
  65. 420   IF (X>N) THEN PRINT "Invalid Record Number": GOTO 410
  66. 430   Q1= 2*X+1:GOSUB 1230: REM ---Get the desired record to look at
  67. 440   GOSUB 2300: REM ---Unpack the record---
  68. 450   FOR X=1 TO L(0):PRINT X;"  ";Q$(X);RIGHT$(C$,25-LEN(Q$(X)));D$(X):NEXT X
  69. 460   INPUT "Another Record (Y or N)";W$
  70. 470   IF (W$="Y") OR (W$="y") THEN clearw 2:goto 405
  71. 495   GOSUB 1100: REM ---Close the file---
  72. 499   GOTO 100:REM ---Return to the menu---
  73. 500   REM ---This is the data change program---
  74. 505   GOSUB 1000: REM ---Open the file used for data storage---
  75. 510   Q1=1:GOSUB 1230:GOSUB 2100: REM ---Get file information and unpack it---
  76. 515   INPUT  "Which record would you like to change ";Z
  77. 520   IF (Z<1) OR (Z>N) THEN 515: REM ---Not a legal record goto 515
  78. 525   Q1=2*Z+1:GOSUB 1230:GOSUB 2300: REM ---Get and unpack desired record---
  79. 530   FOR X=1 TO L(0):PRINT X;"  ";Q$(X);RIGHT$(C$,25-LEN(Q$(X)));D$(X):NEXT X
  80. 535   INPUT "The number of the item to be changed & `0' if none ";I
  81. 540   IF I=0 THEN 580: REM ---Go store result---
  82. 545   IF (I<1) OR (I>L(0)) THEN 535: REM ---Illegal item number---
  83. 550   PRINT Q$(I);" Should be ";:INPUT D$(I): REM ---Input correct answer---
  84. 555   GOTO 530: REM ---Print out correct data and ask for more corrections---
  85. 580   GOSUB 2200:Q1=2*Z+1:GOSUB 1200:REM ---Pack and save data back onto disk---
  86. 590   GOSUB 1100:REM ---Close the file---
  87. 599   GOTO 100:REM --- Return to the menu---
  88. 600   REM ---This is the data search program---
  89. 601   GOSUB 1000:REM ---Open the file used for data storage---
  90. 605   Q1=1:GOSUB 1230:GOSUB 2100:REM ---Pack and save data back onto disk
  91. 610   FOR X=1 TO L(0):PRINT X;"  ";Q$(X):NEXT X:REM ---List the fields---
  92. 620   INPUT "Which item would you like to search ";I
  93. 625   IF (I<1) OR (I>L(0)) THEN PRINT "Not a Valid Item": GOTO 620
  94. 627   INPUT "What should that item be ";E$
  95. 630   FOR Y=0 TO N:Q1=2*Y+1:GOSUB 1230:GOSUB 2300:REM ---Get and unpack each record---
  96. 640   IF E$=LEFT$(D$(I),LEN(E$)) THEN PRINT  Y;LEFT$(B$,4-LEN(STR$(Y)));:FOR Z=1 TO L(0):PRINT D$(Z);"  ";:NEXT Z:PRINT :REM ---If item found print record---
  97. 645   NEXT Y
  98. 660   INPUT "Another Search (Y or N)";E$
  99. 670   IF (E$="Y") OR (E$="y") THEN clearw 2:goto 610
  100. 690   GOSUB 1100: REM ---Close file---
  101. 699   GOTO 100:REM ---Return to the menu---
  102. 700   REM ---This is the data delete program---
  103. 705   GOSUB 1000: REM ---Open the file used for data storage---
  104. 710   Q1=1:GOSUB 1230:GOSUB 2100:REM ---Get file information and unpack it---
  105. 715   INPUT "Which record would you like to delete? `0'if none";I
  106. 720   IF (I=0) THEN 790: REM ---Don't delete any
  107. 725   IF (I>N) OR (I<0) THEN 715: REM ---Not a legal record---
  108. 730   IF (I=N) THEN 780: REM ---Delete last record---
  109. 735   FOR X=I TO N-1:Q1=2*X+3:GOSUB 1230:Q1=2*X+1:GOSUB 1200:NEXT X:REM ---Shift all following records---
  110. 780   N=N-1:GOSUB 2000:Q1=1:GOSUB 1200: REM --Reset the header back one pointer--
  111. 790   GOSUB 1100: REM --close the file ---
  112. 799   GOTO 100: REM ---Return to the menu---
  113. 800   END
  114. 1000  OPEN "R",1,F$:FIELD 1,127 AS B$:RETURN: REM ---Open file-all results=B$---
  115. 1100  CLOSE 1:RETURN:REM ---Close that file---
  116. 1199  REM ---PUT SUBROUTINE---
  117. 1200  IF LEN(A$)>127 THEN LSET B$=LEFT$(A$,127):PUT 1,Q1:LSET B$=RIGHT$(A$,(LEN(A$)-127)):PUT 1,Q1+1:RETURN
  118. 1210  LSET B$=A$:PUT 1,Q1:LSET B$="  ":PUT 1,Q1+1:RETURN
  119. 1220  REM ---GET SUBROUTINE---
  120. 1230  GET 1,Q1:M$=B$:GET 1,Q1+1:N$=B$:A$=M$+N$:RETURN
  121. 2000  REM ---PACKING AND UNPACKING SUBROUTINES---
  122. 2001  REM Pack 0 a$ is N,L(0),L(1),...L(N),Q$(1),...Q$(X)
  123. 2002  A$=MKI$(N)+MKI$(L(0)):REM ---First enter the number of records---
  124. 2003  FOR X=1 TO L(0):REM Then the number of fields and lengths of fields
  125. 2004  L(X)=LEN(Q$(X)):A$=A$+MKI$(L(X))
  126. 2005  NEXT X
  127. 2006  FOR X=1 TO L(0):REM  Then store the question in record 0
  128. 2007  A$=A$+Q$(X)
  129. 2008  NEXT X
  130. 2009  RETURN
  131. 2100  REM Unpack record 0
  132. 2101  L(0)=CVI(MID$(A$,3,2)):N=CVI(MID$(A$,1,2)):REM number of fields and records
  133. 2102  LT=5+2*L(0):REM Starting byte position
  134. 2103  FOR X=1 TO L(0):REM Unpacking strings
  135. 2104  L(X)=CVI(MID$(A$,2*X+3,2))
  136. 2105  Q$(X)=MID$(A$,LT,L(X))
  137. 2106  LT=LT+L(X):REM Pointer for the next string
  138. 2107  NEXT X
  139. 2108  RETURN
  140. 2200  REM Pack n - packs records for record n
  141. 2201  A$=""
  142. 2202  FOR X=1 TO L(0):REM pack record n
  143. 2203  L(X)=LEN(D$(X)):A$=A$+MKI$(L(X))
  144. 2204  NEXT X
  145. 2205  FOR X=1 TO L(0)
  146. 2206  A$=A$+D$(X)
  147. 2207  NEXT X
  148. 2208  RETURN
  149. 2300  REM Unpack n - unpacks record n
  150. 2301  LT=2*L(0)+1
  151. 2302  FOR X=1 TO L(0)
  152. 2303  L(X)=CVI(MID$(A$,2*X-1,2))
  153. 2304  D$(X)=MID$(A$,LT,L(X))
  154. 2305  LT=LT+L(X):NEXT X
  155. 2306  RETURN
  156. əLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL